home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH6 / SRC / LEASTSQ.FRM (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1996-03-28  |  3.9 KB  |  125 lines
  1. VERSION 4.00
  2. Begin VB.Form LeastSquareForm 
  3.    Caption         =   "Least Squares"
  4.    ClientHeight    =   5310
  5.    ClientLeft      =   2085
  6.    ClientTop       =   900
  7.    ClientWidth     =   4830
  8.    Height          =   6000
  9.    Left            =   2025
  10.    LinkTopic       =   "Form1"
  11.    ScaleHeight     =   354
  12.    ScaleMode       =   3  'Pixel
  13.    ScaleWidth      =   322
  14.    Top             =   270
  15.    Width           =   4950
  16.    Begin VB.CommandButton CmdGo 
  17.       Caption         =   "Go"
  18.       Default         =   -1  'True
  19.       Enabled         =   0   'False
  20.       Height          =   375
  21.       Left            =   2040
  22.       TabIndex        =   1
  23.       Top             =   4920
  24.       Width           =   615
  25.    End
  26.    Begin VB.PictureBox Canvas 
  27.       AutoRedraw      =   -1  'True
  28.       Height          =   4815
  29.       Left            =   0
  30.       ScaleHeight     =   317
  31.       ScaleMode       =   3  'Pixel
  32.       ScaleWidth      =   317
  33.       TabIndex        =   0
  34.       Top             =   0
  35.       Width           =   4815
  36.    End
  37.    Begin VB.Menu mnuFile 
  38.       Caption         =   "&File"
  39.       Begin VB.Menu mnuFileExit 
  40.          Caption         =   "E&xit"
  41.       End
  42.    End
  43. Attribute VB_Name = "LeastSquareForm"
  44. Attribute VB_Creatable = False
  45. Attribute VB_Exposed = False
  46. Option Explicit
  47. Dim NumPts As Integer
  48. Dim PtX() As Single
  49. Dim PtY() As Single
  50. ' ************************************************
  51. ' Compute the m and b values for the least squares
  52. ' line.
  53. ' ************************************************
  54. Sub GetLeastSquaresValues(num As Integer, X() As Single, Y() As Single, mvalue As Single, bvalue As Single)
  55. Dim A As Single
  56. Dim B As Single
  57. Dim C As Single
  58. Dim D As Single
  59. Dim i As Integer
  60.     ' Compute the sums.
  61.     For i = 1 To NumPts
  62.         A = A + PtX(i) * PtX(i)
  63.         B = B + PtX(i)
  64.         C = C + PtX(i) * PtY(i)
  65.         D = D + PtY(i)
  66.     Next i
  67.     mvalue = (B * D - C * NumPts) / (B * B - A * NumPts)
  68.     bvalue = (B * C - A * D) / (B * B - A * NumPts)
  69. End Sub
  70. ' ************************************************
  71. ' Add this point to the list of points.
  72. ' ************************************************
  73. Private Sub Canvas_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  74. Const GAP = 2
  75.     ' If this is the first point, erase the screen.
  76.     If NumPts < 1 Then Canvas.Cls
  77.     ' Record the new point.
  78.     NumPts = NumPts + 1
  79.     ReDim Preserve PtX(1 To NumPts)
  80.     ReDim Preserve PtY(1 To NumPts)
  81.     PtX(NumPts) = X
  82.     PtY(NumPts) = Y
  83.     ' Display the point.
  84.     Canvas.Line (X - GAP, Y - GAP)-(X + GAP, Y + GAP), , BF
  85.     ' If NumPts >= 2, enable the Go button.
  86.     If NumPts >= 2 Then CmdGo.Enabled = True
  87. End Sub
  88. ' ************************************************
  89. ' Draw the least squares fit curve.
  90. ' ************************************************
  91. Private Sub CmdGo_Click()
  92.     CmdGo.Enabled = False
  93.     DrawCurve
  94.     ' Prepare to get a new set of points.
  95.     NumPts = 0
  96. End Sub
  97. ' ************************************************
  98. ' Draw the least squares line.
  99. ' ************************************************
  100. Sub DrawCurve()
  101. Dim mvalue As Single
  102. Dim bvalue As Single
  103. Dim x1 As Single
  104. Dim x2 As Single
  105. Dim y1 As Single
  106. Dim y2 As Single
  107. Dim i As Integer
  108.     ' Get the m and b values for the line.
  109.     GetLeastSquaresValues NumPts, PtX, PtY, mvalue, bvalue
  110.     ' Find the minimum and maximum X values.
  111.     x1 = PtX(1) ' This will be the minimum X value.
  112.     x2 = x1     ' This will be the maximum X value.
  113.     For i = 2 To NumPts
  114.         If x1 > PtX(i) Then x1 = PtX(i)
  115.         If x2 < PtX(i) Then x2 = PtX(i)
  116.     Next i
  117.     ' Draw the line.
  118.     y1 = mvalue * x1 + bvalue
  119.     y2 = mvalue * x2 + bvalue
  120.     Canvas.Line (x1, y1)-(x2, y2)
  121. End Sub
  122. Private Sub mnuFileExit_Click()
  123.     Unload Me
  124. End Sub
  125.